COMMENT ⊗   VALID 00004 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(de nouvar (pat save) (nouv1 pat))
C00007 00003	(de traiter (a env tab aid aid1 n o alist pat patt save savaid lsym)
C00016 00004	(df m-i (l env lenv glenv)
C00018 ENDMK
C⊗;
(de nouvar (pat save) (nouv1 pat))
(de grand-patron (x %globales% m n o p r s)
    (cond ((and (atom x) (setq m (get x expr)))
            (grand-patron (cons 'de (cons x (cdr m))) %globales%))
          ((eq (car x) 'de)
            (setq m (cddr x))
            (mapc (car m) '(lambda (x)
               (setq o (nconc1 o 
                   (setq n ['! '(1 2 3 4) [x '(%nb%)]]))
                     r (nconc1 r ['traiter n]))))
            (mapc %globales% '(lambda (x)
               (setq r (nconc1 r ['traiter (car x)]))))
            (or (cdr r) (setq r (car r)))
            ((lambda (lfonct)
              (setq n (boulot-boulot (car m) (cdr m))))
             (cons [(cadr x)
                    [o ['ref r
                         (setq n ['! '(1 2 3 4) [(nbneuf) '(%nb%)]])
                        '--> ['rec (cadr x) n]]]]
                   lfonct))
            (if (eq (car n) '*) (erreur (cdr n))
                (mapc n '(lambda (x)
                   (setq p (nconc p (resume (car x) (cadr x))))))
                (setq p (if r (cons 'ref (cons r p))
                            (caddr p)))
                [(cadr x) [o p]]))))
(de boulot-boulot (v c env)
    (while v
       (setq env (nconc1 env [(nextl v) '! '(1 2 3 4)
                              [(nbneuf) '(%nb%)]])))
    (setq %aaae (escape hors
       (traiter (cons 'progn c) [(nconc env %globales%)]))))
(de resume (lenv val n)
    (cond ((cdr lenv)
            (setq n (mapct (envir (cdr lenv)) '(lambda (x)
                     (and (not (memq (car x) (car m)))
                          x))))
            (resaid (if n [ '%proc% val (cons 'phys n)] 
                        val)))
          (t (resaid val))))
(de resaid (y m)
    (mapc (car lenv) '(lambda (x)
          (setq m (nconc1 m (cdr x)))))
    (and (setq n (cassq '%w% (caddr x)))
         (setq y ['%w% y n]))
    ((if (eq (car r) 'traiter) 'nconc 'cons)                  
     m ['--> y]))
(de evalue (l alist ;; aid m patt)
    (cond ((atom l) [[env l tab]])
          ((eq (car l) 'traiter)
            (traiter (cadr l) env tab))
          ((eq (car l) '%proc%)
            (eprogn (meta-prep (cddr l) alist))
            (evalue (cadr l) alist))
          ((atom (car l))
            (setq aid (evalue (cdr l) alist))
            (mapc aid '(lambda (x)
               (setq patt (nconc1 patt [(car x) (cons (car l) (cadr x))
                                        (caddr x)]))))
            patt)
          ((eq (caar l) 'traiter)
            (setq aid (traiter (cadar l) env tab))
            (aid)
            patt)
          (t (setq aid (evalue (car l) alist)) (aid) patt)))
(de aid (mq)
    (mapc aid '(lambda (x)
       (setq env (car x) tab (caddr x)
             m (evalue (cdr l) alist))
       (mapc m '(lambda (y)
          (setq patt (nconc1 patt [(car y)
             ((if mq 'append 'cons)                                            
                (meta-prep (cadr x) (caddr y))  (cadr y))
             (caddr y)]))))))))
(de traiter (a env tab aid aid1 n o alist pat patt save savaid lsym)
  (cond ((atom a)
          [[env (cond ((setq m (assq a (envir env))) (cdr m))
                      ((memq a '(t nil lambda quote)) a)
                      ((numbp a) (cons '%nb% (repete a '(1))))
                      ((hors (erreur1)))) tab]])
        ((setq aid (cassq (car a) lfonct))
          (escape ot (while aid
             (cond ((setq save (meta-match (caar aid) (cdr a)))
                     (setq save (caar save)
                           aid (cdar aid))
                     (ot (cond ((eq (caar aid) 'ref)
                            (setq pat (evalue (meta-prep (cadar aid) save)
                                              save)
                                  aid1 (nouvar (meta-prep (cddar aid) save))
                                  savaid aid1)
                            (print a)
                            (mapc pat '(lambda (x)
                               (setq aid1 savaid)
                               (envpr x)
                               (while aid1
                                 (terpri)
                                 (print "L'unification:")
                                 (print (car aid1))
                                 (print '<::>)
                                 (print (cadr x))
                                 (cond ((setq alist
                                         (intersection (car aid1) (cadr x)))
                   (print "donne:" alist)
                   (mapc alist '(lambda (al)
                      (setq tab
                        (cond ((caddr x) (%w% (fusion (corr1 (caddr x) al)
                                                      al (cadr x))
                                               (cassq '%w% al)))
                              (t al))
                            env (correnv (car x) al)
                            patt (append patt (escape hors
                              (evalue (meta-prep (caddr aid1) al) al)))))))
                    (t (print "echoue")))
                                 (setq aid1 (cdddr aid1)))))
                             (or patt (hors ['* (car a) 'non 'defini 
                                              'pour pat])))
                               (t (evalue (meta-prep (car aid) save) save)))))
                   (t (nextl aid))))))
        ((eq (car a) 'while)
            ((lambda (lfonct)
              (traiter '(g) env tab))
             (cons (grand-patron
                    ['de 'g nil ['if (cadr a)
                                 (cons 'progn (append (cddr a) (cons '(g))))]]
                    (global (envir env) nil t))
                   lfonct)))
        ((eq (caar a) lambda)
          (setq lfonct (cons (grand-patron
            (cons 'de (cons (setq m (gensym)) (cdar a)))
            (global (envir env) (cadar a))) lfonct))
          (rplaca a m)
          (traiter a env tab))
        ((setq m (get (car a) expr))
          (setq lfonct
            (cons (grand-patron (cons 'de (cons (car a) (cdr m)))
                                (global (envir env) (cadr m) t))
                  lfonct))
          (traiter a env tab))
        ((setq m (assq (car a) (envir env)))
          (traiter (cons (cdr m) (cdr a)) env tab))
        (t (let ((x (1varnf '(%nb%))))
;globaliser aussi l'environnement pour les effets de bord possibles;
           (cons [env x (%w% tab (cons x a))])))))
(de global (x y s)
  (mapct x '(lambda (x)
     (if (memq (car x) y) nil (glob)))))
(de glob () (if s (cons (car x) (1varnf '(%nb%))) x))
(de intersection (x y)
  (mapcar (meta-match x y) '(lambda (z) (append (car z) (cadr z)))))
(de a-jour (lal1 lal2 m)
  (mapc lal2 '(lambda (x) (setq m (nconc m (corrige lal1 x))))) m)
(de correnv (en m n)
  (while en (setq n (nconc1 n (corr1 (nextl en) m)))) n)
(de erreur1 () (list '* 'variable a 'non 'definie))
(de erreur (x) x)
(de envir (b ;; m n)
  (mapc (reverse b) '(lambda (x)
    (while x
       (cond ((assq (caar x) n))
             (t (setq n (nconc1 n (car x)))))
       (nextl x))))  n)
(df phys (l) (nconc1 env l))
(de nouv1 (pat m)
  (cond ((atom pat) pat)
        ((memq (car pat) '(! ?))
          (let ((x (cassq (caaddr pat) lsym))(m (nbneuf)))
             [(car pat) (cadr pat)
               [(or x (and (setq lsym (cons (cons (caaddr pat) m) lsym))
                           m))
                (nouv1 (cadr (caddr pat)))]]))
        ((eq (car pat) '%l%)
          (setq lsym (cons (cons (setq m (caaddr pat)) m) lsym))
          (mcons '%l%
                 (nouv1 (cadr pat))
                 (list m (nouv1 (cadr (caddr pat))))
                 (nouv1 (cdddr pat))))
        (t (cons (nouv1 (nextl pat)) (nouv1 pat))) ))
(de envpr (x)
    (lzatpr (nextl x))
    (status 7 8)
    (terpri)
    (print 'ref (car x))
    (status 7 12)
    (terpri)
    (rulepr aid1)
    (status 7 0)
    (terpri))
(de lzatpr (x)
    (while x
       (zatpr (nextl x))
       (if x (print 'puis))))
(de zatpr (x)
  (while x
    (print (caar x) '= (cdar x))
    (nextl x)))
(de rulepr (x)
  (while x
    (print (nextl x) (nextl x) (nextl x))))
(df m-i (l env lenv glenv)
  (print "pour sortir, taper (stop)")
  (while l (setq env (nconc1 env (cons (nextl l) (1varnf '(%nb%))))))
  (setq glenv (setq lenv [env]))
  (setq lenv [lenv])
  (meta-interp))
(de meta-interp (exp m)
  (if (equal '(stop) (setq exp (read))) nil
    (if (eq (car exp) 'de) (setq lfonct (cons (grand-patron exp 
           (global (envir env) (caddr exp) t)) lfonct))
      (mapc lenv '(lambda (env)
        (setq m (nconc m (escape hors (traiter exp env))))))
     (if (eq (car m) '*) (print m)
      (ifn (cdr m) (progn (setq m (car m)
                                lenv [(nextl m)])
                          (if (setq n (cassq '%w% (cadr m)))
                              (print '%w% n))
                          (print 'valeur: (car m)))
        (setq k 0 lenv nil)
        (mapc m '(lambda (x)
          (setq lenv (cons (car x) lenv))
          (print 'cas (incr k))
          (lzatpr (nextl x))
          (if (setq n (cassq '%w% (cadr x)))
              (print '%w% n))
          (print 'valeur: (car x))))
        (setq lisenv m m nil))))
    (meta-interp)))